home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Button.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  4.5 KB  |  150 lines
  1. ;;;
  2. ;;;; B u t t o n . s t k       --  Label, Button, Check button and Radio button
  3. ;;;;                      class definitions
  4. ;;;;
  5. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6. ;;;; 
  7. ;;;; Permission to use, copy, and/or distribute this software and its
  8. ;;;; documentation for any purpose and without fee is hereby granted, provided
  9. ;;;; that both the above copyright notice and this permission notice appear in
  10. ;;;; all copies and derived works.  Fees for distribution or use of this
  11. ;;;; software or derived works may only be charged with express written
  12. ;;;; permission of the copyright holder.  
  13. ;;;; This software is provided ``as is'' without express or implied warranty.
  14. ;;;;
  15. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  16. ;;;;    Creation date: 30-Mar-1993 15:39
  17. ;;;; Last file update: 21-Dec-1995 18:19
  18.  
  19.  
  20. (require "Basics")
  21.  
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23. ;;;;
  24. ;;;; <Label> class
  25. ;;;;
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27. (define-class <Label>(<Tk-simple-widget> <Tk-simple-text> <Tk-sizeable> <Tk-bitmap>)
  28.   ())
  29.  
  30. (define-method tk-constructor ((self <Label>))
  31.   Tk:label)
  32.  
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34. ;;;;
  35. ;;;; <Button> class
  36. ;;;;
  37. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38. (define-class <Button> (<Label> <Tk-reactive>)
  39.   ())
  40.  
  41. (define-method tk-constructor ((self <Button>))
  42.   Tk:button)
  43.  
  44.  
  45. ;;;
  46. ;;; Buttons methods
  47. ;;;
  48. (define-method flash ((self <Button>))
  49.   ((slot-ref self 'Id) 'flash))
  50.  
  51. (define-method invoke ((self <Button>))
  52.   ((slot-ref self 'Id) 'invoke))
  53.  
  54. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55. ;;;;
  56. ;;;; <Tk-complex-button>
  57. ;;;;
  58. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59. (define-class <Tk-complex-button> (<Button>)
  60.   ((indicator-on    :accessor     indicator-on
  61.             :init-keyword :indicator-on
  62.             :tk-name      indicatoron
  63.             :allocation   :tk-virtual)
  64.    (select-color    :accessor     select-color
  65.             :init-keyword :select-color
  66.             :tk-name      selectco
  67.             :allocation   :tk-virtual)
  68.    (select-image    :accessor     select-image
  69.             :init-keyword :select-image
  70.             :tk-name      selectim
  71.             :allocation   :tk-virtual)
  72.    (string-value    :accessor     string-value
  73.             :init-keyword :string-value
  74.             :tk-name      stringval
  75.             :allocation   :tk-virtual)
  76.    (variable         :accessor     variable 
  77.             :init-keyword :variable 
  78.             :allocation   :tk-virtual)))
  79.  
  80. ;;;
  81. ;;; <Tk-complex-button> methods
  82. ;;; 
  83. (define-method select ((self <Tk-complex-button>))
  84.   ((slot-ref self 'Id) 'select))
  85.  
  86. (define-method deselect ((self <Tk-complex-button>))
  87.   ((slot-ref self 'Id) 'deselect))
  88.  
  89. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90. ;;;;
  91. ;;;; <Check-button> class definition
  92. ;;;;
  93. ;;;; Define a fictive slot ``value''. This slots permits to initialize
  94. ;;;; the check button at creation time -- i.e you can do
  95. ;;;;     (define c (make <Check-button> :text "Test" :value #t))
  96. ;;;;
  97. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98.  
  99.  
  100. (define-class <Check-button> (<Tk-complex-button>)
  101.   ((on-value  :accessor     on-value 
  102.           :init-keyword :on-value 
  103.           :allocation   :tk-virtual
  104.           :tk-name        onvalue)
  105.    (off-value :accessor     off-value
  106.           :init-keyword :off-value
  107.           :allocation   :tk-virtual
  108.           :tk-name        offvalue)
  109.    ;; fictive slot 
  110.    (value     :accessor        value
  111.           :init-keyword :value
  112.           :allocation   :virtual
  113.           :slot-ref     (lambda (o)  
  114.                   (eval-string (slot-ref o 'variable)))
  115.           :slot-set!    (lambda (o v) 
  116.                   (eval `(set! ,(string->symbol 
  117.                          (slot-ref o 'variable)) ,v))))))
  118.  
  119. (define-method tk-constructor ((self <Check-button>))
  120.   Tk:checkbutton)
  121.  
  122. ;;;
  123. ;;; <Check-button> methods
  124. ;;;
  125. (define-method initialize ((self <Check-button>) args)
  126.   (next-method)
  127.   (let ((val (get-keyword :value  args #f)))
  128.     ;; If a value is specified at init-time init, set it.
  129.     (when val (slot-set! self 'value val))))
  130.  
  131. (define-method toggle ((self <Check-button>))
  132.   ((slot-ref self 'Id) 'toggle))
  133.  
  134.  
  135. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  136. ;;;;
  137. ;;;; <Radio-button> class definition
  138. ;;;;
  139. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  140.  
  141. (define-class <Radio-button> (<Tk-complex-button>)
  142.   ((value   :accessor value :init-keyword :value :allocation :tk-virtual)))
  143.  
  144.  
  145. (define-method tk-constructor ((self <Radio-button>))
  146.   Tk:radiobutton)
  147.  
  148.  
  149. (provide "Button")
  150.